home *** CD-ROM | disk | FTP | other *** search
/ CU Amiga Super CD-ROM 27 / CU Amiga Magazine's Super CD-ROM 27 (1998)(EMAP Images)(GB)[!][issue 1998-10].iso / CUCD / Programming / JForth / JTools / Demos / demo_lines < prev    next >
Encoding:
Text File  |  1991-12-30  |  4.3 KB  |  173 lines
  1. \ Copyright 1986  Delta Research
  2.  
  3. \ a 'LINES' demo for JForth...Mike Haas, 18-jan-87
  4.  
  5. exists? module   exists? wd_width 0=   and
  6. .if
  7.     getmodule includes
  8. .then
  9.  
  10.  
  11. include? gr-currport    ju:Amiga_Graph
  12. include? choose         ju:random
  13. include? ev.getclass    ju:Amiga_Events
  14.  
  15.  
  16. ANEW TASK-DEMO_LINES
  17.  
  18.  
  19. \ an interface to the RectFill() routine...
  20.  
  21. : GR.RECTFILL  ( l t r b -- )
  22.     4 x>r   gr-currport @  4 xr>    call graphics_lib RectFill  drop  ;
  23.  
  24. \ a data type to support 4 points...
  25.  
  26. : rect   ( -- create rectangle data type )
  27.     create  0 , 0 , 0 , 0 ,
  28.     does> ;
  29.  
  30. : rect@  ( rect-address -- l t r b )
  31.     dup [ 4 cells ] literal + swap
  32.     DO  i @  cell
  33.     +LOOP   ;
  34.  
  35. : rect!  ( l t r b rect-address -- )  >r
  36.     swap 2 x>r  swap  2 xr>  2swap  r>
  37.     dup [ 4 cells ] literal + swap
  38.     DO  i !  cell
  39.     +LOOP   ;
  40.  
  41. : rect+!  ( deltaleft deltatop deltaright deltabottom rect-addr -- )
  42.     >r   \ save base-addr
  43.     r@  [ 3 cells ] literal +  +!
  44.     r@  [ 2 cells ] literal +  +!
  45.     r@  cell+ +!
  46.     r>  +!   ;
  47.  
  48. : shiftup  ( '16 shift' 4 numbers )
  49.     3 x>r   16 shift  r> 16 shift  r> 16 shift  r> 16 shift   ;
  50.  
  51. : shiftdown  ( '-16 shift' 4 numbers )
  52.     3 x>r -16 shift  r> -16 shift  r> -16 shift  r> -16 shift   ;
  53.  
  54. \ storage for the last drawn line endpoints...
  55. rect lastpoints
  56.  
  57. \ storage for the last window size...
  58. variable lastheight
  59. variable lastwidth
  60.  
  61. \ storage for how much to correct each for this pass...
  62. rect deltapoints
  63.  
  64.  
  65. : 2CHOOSES  ( n1 -- random1 random2 , both less than or equal to n1 )
  66.     dup choose swap choose  ;
  67.  
  68. : >LTRB  ( width height -- left top right bottom , 2cnd pair > 1st pair )
  69.     2chooses   ( -- w y y , Generate two random Y values )
  70.     2sort >r  ( -- w y1 , push highest Y value )
  71.     swap 2chooses  ( -- y1 x x )
  72.     2sort >r swap r> r>    ( -- x1 y1 x2 y2 )   ;
  73.  
  74. : TWO-POINTS  ( width height -- x1 y1 x2 y2 , 2 points without a sort )
  75.     2chooses  >r >r  \ get 2 'y' values
  76.     2chooses  r> swap r>  ;
  77.  
  78. variable #lines/pass  50 #lines/pass !
  79. variable #lines-done
  80.  
  81. : RANDOM.LINE  ( -- , draw random box in bounds , in current color)
  82.     \ move toward the destination...
  83.     deltapoints lastpoints  4 0
  84.     DO   ( -- deltabase lastbase )
  85.         over @  over @  +
  86.         over !  cell+ swap cell+ swap
  87.     LOOP 2drop
  88.     lastpoints rect@ shiftdown  2swap  gr.move gr.draw    ;
  89.  
  90. .need ?closed
  91. : ?CLOSED ( -- flag , true if close button hit )
  92.     gr-curwindow @ ev.getclass
  93.     CLOSEWINDOW =
  94. ;
  95. .then
  96.  
  97. : CHANGE-COLOR  ( -- )
  98. \ This only works on V1.2 Beta-4 of Amiga-DOS.
  99. \ Other versions do not change color. They always use 3 .
  100.     gr.color@ 1+ 3 and gr.color!  ( Cycle colors. )
  101. ;
  102.  
  103. variable delays
  104.  
  105. : check-speed  ( -- )
  106.     ?terminal
  107.     IF   key dup ascii 0 ascii 9 within?
  108.         IF   dup $ 30 - delays !
  109.         THEN drop
  110.     THEN ;
  111.  
  112. variable #shifts  9 #shifts !
  113. : delay?  ( -- )  delays @ -dup
  114.     IF    #shifts @ shift  0 do loop
  115.     THEN ;
  116.  
  117. : RANDOM.LINES (  -- , draw lines in multiple colors )
  118. \ make sure 1st line gets drawn...
  119.     lastwidth on
  120.     lastheight on
  121. \ get random place to start...
  122.     gr-curwindow @  ..@ wd_width   dup lastwidth !
  123.     gr-curwindow @  ..@ wd_height  10 - dup lastheight !
  124.     two-points shiftup lastpoints rect!
  125.     BEGIN change-color  check-speed
  126.         \ get some new points, calculate deltapoints
  127.         gr-curwindow @  ..@ wd_width
  128.         gr-curwindow @  ..@ wd_height 10 - two-points  ( -- l t r b )
  129.         shiftup deltapoints rect!
  130.         lastpoints deltapoints  4 0
  131.         DO   ( -- adrlast adrnew )  dup @  2 pick @  -
  132.             #lines/pass @ / over !
  133.             cell+ swap cell+ swap
  134.         LOOP 2drop
  135.         \ now go ahead and draw the lines...
  136.         #lines/pass @  0
  137.         DO  delay?
  138. \ Stay within bounds of current window.
  139. \ Access window structure. ( In 'C':   gr_currentw->width )
  140.             gr-curwindow @  ..@ wd_width
  141.             gr-curwindow @  ..@ wd_height
  142.             10 -  \ compensate for title-bar
  143.             over lastwidth @ = over lastheight @ = and 0=
  144.             IF   \ window was changed...  ( -- width height )
  145.                 0 gr.color!  0 0 2over  gr.rectfill
  146.                 2dup lastheight !  lastwidth !
  147.                 two-points  ( -- l t r b ) shiftup lastpoints rect!
  148.                 leave
  149.             ELSE 2drop   random.line  1 #lines-done +!
  150.             THEN
  151.         LOOP
  152.         ?closed
  153.     UNTIL
  154. ;
  155.  
  156. .need boxwindow
  157. NewWindow BoxWindow   ( Create a template for the new window. )
  158. .then
  159.  
  160. : LINES ( -- )
  161.     cr ." LINES - Hit CLOSE BOX to stop!" cr
  162.     gr.init            ( Initialize graphics system. )
  163.     BoxWindow NewWindow.Setup     ( Set defaults for window )
  164. \ Create window from template and make it the current window.
  165.     BoxWindow  gr.opencurw
  166.     IF  0 #lines-done !
  167.         random.lines
  168.         gr.closecurw
  169.         cr #lines-done @ u. ." lines drawn!" cr
  170.     THEN
  171.     gr.term
  172. ;
  173.